perm filename MAPS1.SAI[SYS,HE]7 blob
sn#073006 filedate 1973-11-20 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00019 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 MAPS1 - programs for the parsing of the scene.
C00007 00003 _ external and forward procedures - LCRV
C00009 00004 _ DTRCE, LINDL, QTRCE
C00011 00005 _ MLCR, REVIVE, UPPDAL
C00013 00006 _ UNTST, BREAK
C00015 00007 _ CLUPSC
C00018 00008 _ CLUPSC cont
C00019 00009 _ FUSABL
C00023 00010 _ LFDIF
C00028 00011 _ MAP (VCRKEY)
C00031 00012 _ MAP cont
C00033 00013 _ PARSE
C00036 00014 _ PARSE cont
C00038 00015 _ PARSE cont
C00041 00016 _ PARSE cont.
C00044 00017 _ PARSE cont.
C00046 00018 _ PARSE cont
C00048 00019 _ PARSE end
C00050 ENDMK
C⊗;
COMMENT MAPS1 - programs for the parsing of the scene.;
ENTRY LCRV,LCRL,DTRCE,LINDL,QTRCE,MLCR,REVIVE,CLUPSC,
UPPDAL,FUSABL,LFDIF,MAP,PARSE;
BEGIN "MAPS1"
DEFINE QC(I)="&"" I=""&CVS(I)",
QCO(I)="&"" I=""&CVOS(I)",
QCR(R)="&"" R=""&CVF(R)",
NOTHING="",
CL="'15&'12",
QSCOR="&"" SCORE=""&CVS(CONF)&""/""&CVS(((PARTS[CMPIND,0] LSH -27)
LAND 7)-1)&""/""&CVS(PARTS[CMPIND,0] LAND '777777777)",
BL="'40",
QENP="EXTERNAL PROCEDURE",
QS="STRING",
QESP="EXTERNAL SIMPLE STRING PROCEDURE",
QI="INTEGER",
QR="REAL",
QRI="REFERENCE INTEGER",
QRR="REFERENCE REAL",
QEP="EXTERNAL SIMPLE PROCEDURE",
QEIP="EXTERNAL SIMPLE INTEGER PROCEDURE",
QERP="EXTERNAL SIMPLE REAL PROCEDURE",
QFOP="FORWARD INTERNAL SIMPLE PROCEDURE",
QFOIP="FORWARD INTERNAL SIMPLE INTEGER PROCEDURE",
QFORP="FORWARD INTERNAL SIMPLE REAL PROCEDURE",
_="COMMENT",
LOOP(I,J,K,L)="FOR I←J STEP L UNTIL K DO",
SQTRC="IF DTRACE∨MAPTRC LAND '10012000 THEN QTRCE",
QTRC="IF ¬(MAPTRC LAND '10000000)∧(DTRACE∨MAPTRC LAND '10012000)
THEN QTRCE",
DTRC="IF ¬(MAPTRC LAND '10000000)∧(DTRACE∨MAPTRC LAND '10010000)
THEN DTRCE",
LINSET="DISW←1; DTRC(""LINSRT:""QC(IFREEL)); LINSRT",
BELCRE(I)="LVNEXT(I,-1)",
SAFEX="";
INTEGER IA,DCHAN,CURMAP,TC;
INTERNAL INTEGER PROT,PLIN,PVER,AD0,LNCS1,LNCS2,RAYS,ICH,CMPIND,
BRCH,EOF,DTRACE,KMP,MDCTR,DISW,FLMIND,FTSW,LFDBT,BESTMP,NPRS,
LNCRE0;
EXTERNAL INTEGER NOEPA,NOL,MAXNOL,MAXNOV,LNCRE1,LNCRE2,
PFTOT,MODIF,PLFTOT,MAXPLS,MAXPVS,MAPTRC,SCO,CONF,CMPL;
EXTERNAL REAL RWIC,RMAP;
SAFEX EXTERNAL INTEGER ARRAY DICH[0:1],LCREDE,LFEAT,LVERCO,LINK,
LVERSI,PLINES,PVERTS,PPTRL,PLINE,PLINE2,PFPRO,PFEAT,
LEDG1,LEDG2,LVER,CFEAT[1:1],PFPTR[0:1];
SAFEX EXTERNAL REAL ARRAY XVCOR,YVCOR,XLCOR,YLCOR,CXL,CYL,CCL,RLEN[1:1];
SAFEX EXTERNAL STRING ARRAY PNAME[1:1];
_ external and forward procedures - LCRV;
QEP LINDEL(QI I,J);
QEIP BITS(QI I,J,K);
QEIP MAPCONV(QS CODES);
QEIP INREK(QR X,Y);
QEP UPPDAT;
QEP FTEX;
QENP XREFC(QI I);
QEP UNXREF;
QEIP LACT(QI I);
QERP ANGLIN(QI I,J);
QEIP LVOPP(QI I);
QERP SQRT(QR R);
QEIP MAX0(QI I,J);
QEIP KARN(QR X1,Y1,X2,Y2,X3,Y3,X4,Y4; QI IC);
QEP REKOP(QR X1,Y1,X2,Y2,WI; QRR RL);
QEP WEIGHV(QI I; QRR X,Y,WE);
QEIP MAPREC;
QEP PRECAL;
QEP CALC;
QEIP LVNEXT(QI I,J);
QEP REGREF(INTEGER I);
QEIP MSCVCO(QI ISV, ICV, LADD);
QEIP NEXVER;
QEIP LCRL(QI L);
_ return LCREDE entry for s.v. SV (sign and low 4 octal digits only);
INTERNAL SIMPLE INTEGER PROCEDURE LCRV(INTEGER SV);
RETURN(LCREDE[(SV+1)%2] LAND '400000007777);
_ DTRCE, LINDL, QTRCE;
_ Produces trace output on file "PARSE.TRC" if MAPREC bit 12 is set.;
INTERNAL SIMPLE PROCEDURE DTRCE(STRING S);
BEGIN "DTRC"
IF DTRACE∧DCHAN=-1∨¬DTRACE∧(DTRACE←MAPTRC LAND '10010000) THEN
BEGIN
OPEN(DCHAN←GETCHAN,"DSK",0,0,2,100,BRCH,EOF);
ENTER(DCHAN,"PARS"&CVS(NPRS←NPRS+1)&".TRC",IA)
END;
IF DTRACE∧¬(DTRACE←MAPTRC LAND '10010000) THEN
BEGIN CLOSE(DCHAN); DCHAN←-1 END;
TC←TC+1;
IF MAPTRC LAND '40000 THEN OUTSTR('11&CVS(TC));
IF DTRACE THEN OUT(DCHAN,CL&CVS(TC)&'11&S);
END "DTRC";
_ line deletion with tracing;
INTERNAL SIMPLE PROCEDURE LINDL(INTEGER L,I);
BEGIN DISW←1; DTRC("LINDEL:"QC(L)); LINDEL(L,I) END;
_ Produces trace typeouts, and pauses if correct bit is set in MAPTRC.
Also puts out trace on DSK-file "PARSE.TRC" if bit 12 of MAPTRC is set.;
INTERNAL SIMPLE PROCEDURE QTRCE(STRING S);
BEGIN "QTRC"
IF DTRACE∨MAPREC LAND '10010000 THEN DTRCE(S);
IF MAPTRC LAND '2000 THEN
BEGIN
OUTSTR(CL&S);
IF MAPTRC LAND '4000 THEN
BEGIN
WHILE (ICH←INCHRW)≠":"∧ICH≠"←" DO NOTHING;
IF ICH="←" THEN MAPTRC←MAPCONV(INSTR(":"))
END
END;
END "QTRC";
_ MLCR, REVIVE, UPPDAL;
_ Pushes LC onto the LCREDE-stack for line LN.;
INTERNAL SIMPLE PROCEDURE MLCR(INTEGER LN,LC);
BEGIN "MLCR"
DISW←1;
DTRC("MLCR: "QC(LN)QC(LC));
IF LN THEN LCREDE[LN]←LCREDE[LN] LSH 12 LOR LC
END "MLCR";
_ Pops LCREDE off top of stack, leaving next-to-newest value.;
INTERNAL SIMPLE PROCEDURE REVIVE(INTEGER LN);
BEGIN "REVIVE"
DISW←1;
DTRC("REVIVE: "QC(LN));
IF LN THEN LCREDE[LN]←LCREDE[LN] LSH -12
END "REVIVE";
_ Updates line-display, and waits for a ":" iff SW is on.;
INTERNAL SIMPLE PROCEDURE UPPDAL(INTEGER SW);
BEGIN "UPPDAL"
IF ¬DISW THEN RETURN ELSE DISW←0;
IF SW>0 THEN
BEGIN
LNCRE1←LNCRE0;
DICH[4]←DICH[5]←DICH[6]←1;
UPPDAT;
IF MAPTRC LAND '100000 THEN BEGIN PRECAL; CALC END;
OUTSTR(" D ");
LNCRE1←LNCS1
END;
IF SW THEN
BEGIN
WHILE (ICH←INCHRW)≠":"∧ICH≠"←" DO NOTHING;
IF ICH="←" THEN MAPTRC←MAPCONV(INSTR(":"))
END
END "UPPDAL";
_ UNTST, BREAK;
_ tests cv for active and inactive lines. Returns zero if all lines
connected to cv are active or inactive. If some lines of each type
are connected, it returns the total number of lines;
SIMPLE INTEGER PROCEDURE UNTST(INTEGER CV);
BEGIN "UNTST"
INTEGER L, FL, FLG, N, RET;
FL ← L ← LVERSI[CV];
IF FL<0∨LVER[FL]=L THEN RETURN(0);
FLG ← LACT((FL+1) DIV 2);
RET ← 0;
N ← 1;
WHILE (L←LVER[L])≠FL DO
BEGIN "UNA"
IF LACT((L+1) DIV 2) XOR FLG THEN RET←-1;
N ← N+1;
END "UNA";
RETURN(IF RET THEN N ELSE 0);
END "UNTST";
_ Breaks cv into two cv's, if necessary, and relinks them to seperate
active and inactive lines. New cv contains all inactive lines;
SIMPLE PROCEDURE BREAK(INTEGER CV);
BEGIN "BREAK"
INTEGER LN, L, NCV, I, LAD, N;
N←UNTST(CV);
IF ¬N THEN RETURN;
L ← LVERSI[CV];
NCV ← 0;
LAD ← 1;
DO BEGIN "BRA"
LN ← LVER[L];
IF ¬LACT((L+1) DIV 2) THEN
BEGIN "BRB"
MSCVCO(-L,CV,0);
MSCVCO(L,-NCV,LAD);
LAD ← LAD+1;
IF LAD=2 THEN NCV←LVERCO[L];
END "BRB";
L ← LN;
N ← N-1;
END "BRA" UNTIL ¬N;
END "BREAK";
_ CLUPSC;
_ Cleans up the scene after the isolation of a complete or a best partial,
i.e. removes (to LCREDE=3000+CURMAP) all unused lines coinciding with
or contained within any line of the object. Lines of other objects
linked to common cv's are unlinked and given new cv's;
INTERNAL PROCEDURE CLUPSC;
BEGIN "CLUPSC" INTEGER IA,IB,IC,IV2,IV1, LV, M, N1;
REAL RL,X1,X2,DIFX,DIFY,Y1,Y2;
SAFEX INTEGER ARRAY MP[1:MAXNOV];
DEFINE BK(CV)="IF ¬MP[CV] THEN BEGIN BREAK(CV);MP[CV]←1;END",
RESET="LNCRE1←LNCS1; LNCRE2←LNCS2";
MP[1] ← 0;
ARRBLT(MP[2],MP[1],MAXNOV-1);
N1←2000+2*CURMAP;
RWIC←2.0*RWIC;
M ← N1-1;
LOOP(IA,1,MAXNOL,1) IF M≤LCRL(IA)≤N1 THEN
BEGIN "CLA"
LNCRE2←N1;
LNCRE1←LNCRE2-1;
IB←2*IA;
IV1←LVERCO[IB-1];
X1←XVCOR[IV1];
Y1←YVCOR[IV1];
BK(IV1);
IV1←LVERCO[IB];
X2←XVCOR[IV1];
Y2←YVCOR[IV1];
BK(IV1);
RL←RLEN[IA];
DIFX←RWIC*(X1-X2)/RL;
DIFY←RWIC*(Y1-Y2)/RL;
REKOP(X1+DIFX,Y1+DIFY,X2-DIFX,Y2-DIFY,RWIC,RL);
RESET;
LOOP(IB,1,MAXNOL,1) IF LNCRE1≤(LCREDE[IB] LAND '400000007777)
≤LNCRE2∧ANGLIN(IA,IB)<RMAP THEN
BEGIN "CLC"
IC←2*IB;
IV1←LVERCO[IC-1];
IV2←LVERCO[IC];
IF INREK(XVCOR[IV1],YVCOR[IV1])∧INREK(XVCOR[IV2],
YVCOR[IV2]) THEN
BEGIN "CLB"
LNCRE1←LNCRE2←3000+CURMAP;
MLCR(IB,LNCRE1);
BK(IV2);
BK(IV1);
RESET;
END "CLB";
END "CLC";
END "CLA";
_ CLUPSC cont;
LNCRE2←N1;
LNCRE1←LNCRE2-1;
LOOP(IA,1,MAXNOV,1) IF ¬MP[IA]∧BELCRE(IA) THEN
WEIGHV(IA,XVCOR[IA],YVCOR[IA],RL);
RESET;
RWIC←RWIC/2.0
END "CLUPSC";
_ FUSABL;
_ Returns -1 (else 0) iff L2>0 and lines of s.v:s V1 and V2 are collinear.
If L2≤0, we check whether line of s.v. L1 may be extended through V1
(if L2=0) or V2 (if L2=-1).;
INTERNAL SIMPLE INTEGER PROCEDURE FUSABL(INTEGER L1,L2,V1,V2);
BEGIN "FUSABL"
SHORT INTEGER N1, IL1, IL2, IRET, CV;
SHORT REAL DIST, TEST, CV1, CV2, CX, CY;
IRET ← DIST ← TEST ← 0;
IF L2>0∧(ABS LINK[V1]=V2 ∨ ABS LINK[V2]=V1) THEN IRET ← -1;
IL1←(L1+1)%2;
IF L2≤0 THEN
BEGIN
N1←CASE -L2 OF(V1,V2);
CV1 ← XVCOR[N1];
CV2 ← YVCOR[N1];
CV ← LVERCO[L1];
CX ← CXL[IL1];
CY ← CYL[IL1];
DIST←ABS(CX*CV1+CY*CV2+CCL[IL1])/SQRT(CX↑2+CY↑2);
TEST←SQRT((CV1-XVCOR[CV])↑2+(CV2-YVCOR[CV])↑2)*0.1+0.1;
END;
IF TEST THEN IRET ← DIST≤TEST ELSE IF ¬IRET THEN
BEGIN
IL1←LVOPP(V1);
IL2←LVOPP(V2);
IRET ← KARN(XLCOR[V1],YLCOR[V1],XLCOR[IL1]
,YLCOR[IL1],XLCOR[V2],YLCOR[V2],XLCOR[IL2]
,YLCOR[IL2],-1)=-1;
END;
DTRC("FUSABL: "QC(L1)QC(L2)QC(V1)QC(V2)QCR(DIST)QCR(TEST)QC(IRET));
RETURN(IRET);
END "FUSABL";
_ LFDIF;
_ Returns encoded actions to be performed at end ND2 of LF2 in order to
make it similar to end ND1 of LF1. If TST, other ends must agree (otherwise
error-return = '400). The program also sets the sequential modification
word (MODIF). MODIF contains two bits for each line-position at ND2 of
LF2, telling what to do at that position:
{(0 = no change)(1 = insert line here)(2 = delete line here)
(3 unused code)}.
MODIF←-1 if there is no unambiguous modification possible.
MODIF has its high bit turned on iff end single before insertions.
The program pays no attention to the outer angle at ND2 of LF2.;
INTERNAL SIMPLE INTEGER PROCEDURE LFDIF(INTEGER LF1,LF2,ND1,ND2,TST);
BEGIN "LFDIF"
INTEGER C1,C2,N1,N2,NLDIF,PAR,IA,IB,DEL,CH,IRET,INS,D1,D2,IPD,
DS1,DS2,CHAR,POS1,POS2,INSTOT,NTOT,BARAM;
_ DN is displacement for other ends. DSN originally points to
"#lines>180", later to "#lines≤180". CN = constellation bits.
CH=INS∨DEL all refer to first or last line respectively.;
LABEL OU;
DS1←31-(D1←18*ND1);
DS2←31-(D2←18*ND2);
MDCTR←IRET←INSTOT←NTOT←BARAM←0;
MODIF←2;
RAYS←BITS(LF1,DS1,DS1+3);
IF TST∧((LF1 LSH (-D1)) XOR (LF2 LSH (-D2))) LAND '367500 THEN
BEGIN MODIF←-1; IRET←'400; GO OU END;
_ The other ends are in agreement.;
LOOP(IA,1,2,1)
BEGIN
C1←BITS(LF1,3+D1,4+D1);
C2←BITS(LF2,3+D2,4+D2);
INS←(C2=2∧(C1 LAND 1)∨C2∧¬C1);
CH←-((DEL←C1∧¬C2∨C1=2∧(C2 LAND 1))∨INS);
PAR←C1 LAND 1;
IPD←INS∨PAR∧¬DEL;
IRET←((IRET LSH 1 LOR CH) LSH 1 LOR (-DEL)) LSH 1 LOR PAR;
NLDIF←(N1←BITS(LF1,DS1,DS1+3))-
(N2←BITS(LF2,DS2,DS2+3))+INS-DEL;
IRET←( ( ( (IRET LSH 1 LOR(-(NLDIF<0)))
LSH 4 LOR ABS NLDIF)
LSH 4 LOR (POS1←IF IA=2 THEN 1 ELSE
IF IPD THEN 2 ELSE 1))
LSH 4 LOR (POS2←(IF NLDIF≥0 THEN N1 ELSE N2-INS+DEL)
+(IA=2∧IPD)))
LSH 2 LOR (CHAR←IF ¬CH∧¬NLDIF THEN -(N1>0) ELSE
IF ¬NLDIF THEN 2 ELSE
IF ABS NLDIF=POS2-POS1+1 THEN 2 ELSE
(BARAM←2)+1);
IF CHAR<2 THEN MODIF←MODIF LSH (2*N1) ELSE
BEGIN
IF IA=1∧(CH∨PAR) THEN
MODIF←MODIF LSH 2 LOR (-INS-2*DEL);
N2←IF NLDIF<0 THEN N2+(DEL∨PAR∧¬INS) ELSE N1+IPD;
LOOP(IB,1,N2,1)
MODIF←MODIF LSH 2 LOR
(IF CHAR=3 THEN 3 ELSE
IF NLDIF>0 THEN 1 ELSE
IF ¬NLDIF THEN 0 ELSE 2);
IF IA=2∧(CH∨PAR) THEN
MODIF←MODIF LSH 2 LOR (-INS-2*DEL)
END;
D1←18-D1;
D2←18-D2;
DS1←DS1-5;
DS2←DS2-5;
INSTOT←INSTOT-INS+(0 MAX NLDIF);
NTOT←NTOT+N1
END;
START_CODE LABEL L1, L2;
SKIPG 1,MODIF;
JRST L2;
MOVE 2,MDCTR;
L1: LSH 1,2;
ADDI 2,2;
JUMPG 1,L1;
MOVEM 2,MDCTR;
MOVEM 1,MODIF;
L2: END;
MODIF←(MODIF LAND '177777777777) LOR ((BARAM-(INSTOT=NTOT)) LSH 34);
OU: DTRC("LFDIF: "QCO(LF1)QCO(LF2)QC(ND1)QC(ND2)QCO(IRET)QCO(MODIF));
RETURN(IRET)
END "LFDIF";
_ MAP (VCRKEY);
_ Sets up the expanded parallel datastructure for prototype PROT.
Then initializes mapping arrays according to the basic mapping
provided by the key feature FEAT (c.f. or l.f.) from the scene
into the prototype. Then calls MAPREC to complete the mapping,
described in PLMAP (scene-line corresponding to prot.-line)
and in PVMAP (scene-vertex corresponding to prot.-vertex).;
INTERNAL INTEGER PROCEDURE MAP(INTEGER LSC,LPR,DIR);
BEGIN "MAP"
INTEGER IA,PLNE,SHFT,IB;
SAFEX EXTERNAL INTEGER ARRAY LENDV,LENDP,LLEV,LLEVO,PLMAP,
LFUSE,PLMAPO[1:MAXPLS,0:1],MAPORD,PARCLA,LENCAT,INSLEV,
DEADLN,LFTSTL[1:MAXPLS],VLEV,FLMAPS,PVMAP[1:MAXPVS],
PARTS[1:63,0:1+MAXPLS%3];
SAFEX EXTERNAL REAL ARRAY PARARG[0:MAXPLS],LENARG[0:MAXPLS,0:1,0:1];
_ Returns 1 (else 0) iff present key is unexplored (virgin).;
SIMPLE INTEGER PROCEDURE VIRKEY;
BEGIN "VIRKEY"
INTEGER IA,IB;
IB←((LSC LSH 12 LOR PROT) LSH 12 LOR LPR) LSH 1 LOR DIR;
IF FTSW THEN LOOP(IA,1,FLMIND,1)
IF FLMAPS[IA]=IB THEN RETURN(0) ELSE
ELSE FLMAPS[FLMIND←FLMIND+1]←IB;
RETURN(1)
END "VIRKEY";
SQTRC(CL&"PROT= "&CVS(PROT)&" LPR= "&CVS(LPR)&" LSC= "&CVS(LSC)&
" DIR= "&CVOS(DIR)&CL);
LFDBT←(DIR LSH -1) LAND 1 XOR (DIR←DIR LAND 1);
IF ¬LACT(LSC)∨¬VIRKEY THEN
BEGIN "MAPA"
QTRC(CL&"Key not virgin"&CL);
RETURN(-1)
END "MAPA";
IF MAPTRC LAND '20000 THEN
BEGIN "MAPB"
OUTSTR("NEW KEY - MAPTRC? ");
IF INCHRW="←" THEN MAPTRC←MAPCONV(INSTR(":"));
OUTSTR(CL)
END "MAPB";
_ MAP cont;
_ First set up expanded prototype datastructure,
and zero line-mapping arrays.;
LOOP(IA,1,PLIN,1)
BEGIN "MAPC"
PLNE←PLINE[AD0+IA];
PARCLA[IA]←PLNE LAND '37;
LENCAT[IA]←PLINE2[AD0+IA] LSH -9 LAND 1;
LOOP(IB,0,1,1)
BEGIN "MAPD"
SHFT ← 6*IB;
LENDV[IA,IB]←BITS(PLNE,30-SHFT,35-SHFT);
LENDP[IA,IB]←BITS(PLNE,18-SHFT,23-SHFT)
END "MAPD";
END "MAPC";
PARARG[0] ← -1.0;
ARRBLT(PARARG[1],PARARG[0],MAXPLS);
LEDG1[1]←PVMAP[1]←LENARG[0,0,0]←INSLEV[1]←PLMAP[1,0]←0;
ARRBLT(LEDG1[2],LEDG1[1],MAXNOL-1);
ARRTRAN(LEDG2,LEDG1);
ARRBLT(INSLEV[2],INSLEV[1],MAXPLS-1);
ARRTRAN(LFTSTL,INSLEV);
ARRTRAN(DEADLN,INSLEV);
ARRBLT(PLMAP[1,1],PLMAP[1,0],MAXPLS*2-1);
ARRTRAN(LFUSE,PLMAP);
ARRTRAN(LLEV,PLMAP);
ARRBLT(PVMAP[2],PVMAP[1],MAXPVS-1);
ARRTRAN(VLEV,PVMAP);
ARRBLT(LENARG[0,0,1],LENARG[0,0,0],(MAXPLS+1)*4-1);
_ Initialize the mapping (1 line) and call on MAPREC to do the job.;
MAPORD[1]←LPR;
MLCR(LSC,1001);
PLMAP[LPR,1-LFDBT]←2*LSC-(DIR XOR LFDBT);
LEDG1[LSC] ← '201;
LLEV[LPR,1-LFDBT]←1;
PARTS[CMPIND,0]←PROT;
KMP←1;
RETURN(MAPREC)
END "MAP";
_ PARSE;
_ Will attempt to find a satisfactory parsing of the scene. Note that the
PARTS-storage implementation limits the number of lines to 511.;
INTERNAL PROCEDURE PARSE;
BEGIN "PARSE"
LABEL ITER,REP,REV,ISO,BA1,EXH;
SAFEX INTERNAL REAL ARRAY LENARG[0:MAXPLS,0:1,0:1],PARARG[0:MAXPLS];
SAFEX INTERNAL INTEGER ARRAY MPORDS,MAPIS[1:2*MAXPLS],LENDV,LENDP,
LLEV,LLEVO,PLMAP,LFUSE,PLMAPO[1:MAXPLS,0:1],MAPORD,PARCLA,
DEADLN,LENCAT,INSLEV,EVA,LFTSTL[1:MAXPLS],VLEV,
PVMAP[1:MAXPVS],PARTS[1:63,0:1+MAXPLS%3],FLMAPS[1:MAXNOV];
INTEGER MAXCOM,IA,IB,KADR,PFP,CFP,PRP,SCL1,SCL2,PRL1,PRL2,N1,
LB,UB,FTI,UBI,DIR,IBB,ICC,
ORD,SUCC,IC,ID,MXMXCM,I1,I2,I3,REVER,PARTSI;
_ Returns s.v.-entry in PARTS, corresponding
to prototype line L of mapping M.;
INTERNAL SIMPLE INTEGER PROCEDURE LPARTS(INTEGER M,L);
BEGIN "LPARTS"
IBB←(L+2)%3;
ICC←12*(3*IBB-L);
RETURN(BITS(PARTS[M,IBB],ICC,ICC+11));
END "LPARTS";
_ Returns line indicated in LPARTS(M,L), 0 iff no line specified.;
INTERNAL SIMPLE INTEGER PROCEDURE LPARTL(INTEGER M,L);
BEGIN "LPARTL"
IBB←LPARTS(M,L) LAND '1777;
RETURN(((IF IBB≠'1777 THEN IBB ELSE 0)+1)%2);
END "LPARTL";
LNCRE0←LNCS1←LNCRE1;
LNCS2←LNCRE2;
IF MAPTRC=-1 THEN
BEGIN "PARA"
MAPTRC←0;
LOOP(IA,1,MAXNOL,1)
BEGIN "PARB"
WHILE (IB←LCRL(IA))>2000 DO REVIVE(IA);
IF IB=1001 THEN REVIVE(IA) ELSE
IF IB≥1002∧IB≤1005 THEN LINDL(IA,0)
END "PARB";
UNXREF;
UPPDAL(0);
RETURN
END "PARA";
_ PARSE cont;
DTRACE←MAPTRC LAND '10000;
DCHAN←NPRS←-1;
QTRC(CL&"PARSER RESULTS:"&CL);
_ Initialize PFPTR.;
TC←CURMAP←0;
PARTSI←1+MAXPLS%3;
REP: LB←PLFTOT+1;
UB←PFTOT;
UBI←1;
FTSW←FLMIND←0;
QTRC("CF-keys"&CL);
XREFC(0);
FTEX;
_ Display scene?;
IF MAPTRC LAND '1000000 THEN
BEGIN "PARC"
DISW ← TRUE;
OUTSTR(CL&"SCENE");
UPPDAL(MAPTRC LAND '2000000)
END "PARC";
LOOP(IA,1,PFTOT,1) PFPTR[IA]←PFPTR[IA] LAND '377777777777;
_ Find un-exhausted key of maximum complexity.;
MXMXCM←BESTMP←0;
CURMAP←CURMAP+1;
CMPIND←CURMAP+1;
PARTS[CMPIND,0]←1;
FLMAPS[1] ← 0;
ARRBLT(FLMAPS[2],FLMAPS[1],MAXNOV-1);
ITER: MAXCOM←KMP←SUCC←0;
LOOP(IA,UB,LB,-1) IF MAXCOM<PFPTR[IA] THEN
BEGIN "PARD"
MAXCOM←PFPTR[KADR←IA];
IF MAXCOM=MXMXCM THEN DONE;
END "PARD";
IF ¬MAXCOM THEN GO ISO;
MXMXCM←MAXCOM;
_ PARSE cont;
_ Now exhaust the mappings where this feature serves as the key.;
IC←PFPTR[KADR];
CFP←BITS(IC,12,23);
ORD←IC LAND '4000000000;
DTRC(" "QC(KADR)QC(CFP)QCO(ORD));
_ If L.F., find a line with this feature to start mapping;
LOOP(FTI,1,UBI,1) IF ¬FTSW∨LNCRE1≤LCREDE[FTI] LAND '400000007777
≤LNCRE2∧((IB←LFEAT[FTI])<0∧FTSW=2∨IB>0∧FTSW=1)∧
KADR=IB LAND '7777 THEN
_ Check each instance of feature in scene;
WHILE (CFP←CFP+FTSW) DO
BEGIN "CFPL"
SCL1←IF FTSW THEN FTI ELSE BITS(IC←CFEAT[CFP],24,34);
IF ¬FTSW THEN SCL2←BITS(IC,12,22);
PRP←PFPTR[KADR] LAND '7777;
_ against each prototype containing the feature;
WHILE PRP DO
BEGIN "PRPL"
PROT←BITS(PFPRO[PRP],24,35);
AD0←PPTRL[PROT]-1;
PLIN←PLINES[PROT];
PVER←PVERTS[PROT];
PFP←BITS(PFPRO[PRP],12,23)+1;
_ and each instance for that prototype;
WHILE PFP>1 DO
BEGIN "PFPL"
IB←PFEAT[PFP];
PRL2←PRL1←BITS(IB,24,33);
IF ¬FTSW THEN PRL2←BITS(IB,12,21);
QTRC(CL&"FEAT: "&CVS(KADR)&" SC-LNS: "&
CVS(SCL1)&BL&CVS(SCL2)&
" PROT: "&CVS(PROT)&" PR-LNS: "&
CVS(PRL1)&BL&CVS(PRL2)&CL);
DIR←IF FTSW THEN LFEAT[FTI] LSH -33 ELSE
BITS(IB,34,34) XOR (ID←BITS(IC,35,35));
SUCC←MAP(SCL1,PRL1,DIR);
REVER←0;
_ PARSE cont.;
_ Check results of mapping;
BA1: IF SUCC≥0∧MAPTRC LAND '100 THEN
BEGIN
OUTSTR(CL&"BEST(MAP) - PROT: "&
PNAME[PROT]QSCOR&CL);
LNCRE0←LNCRE2←1006;
LOOP(I1,1,PLIN,1)
MLCR(LPARTL(CMPIND,I1),1006);
UPPDAL(MAPTRC LAND '200);
LNCRE0←LNCS1;
LNCRE2←LNCS2;
LOOP(I1,1,PLIN,1)
REVIVE(LPARTL(CMPIND,I1))
END;
CASE SUCC+1 OF BEGIN GO REV;;GO ISO;END;
_ We have here a maximal partial mapping for
this key. See if it is a maximal partial
for this iteration of PARSE. If it is,
then save inserted lines at LCREDE=1005.;
I3←¬BESTMP∨PARTS[CMPIND,0] LAND '777777777
> PARTS[BESTMP,0] LAND '777777777;
IF I3 THEN
BEGIN
BESTMP←CMPIND;
QTRC(CL&"New best partial"&CL)
END;
LOOP(IA,1,MAXNOL,1)
BEGIN
I2←LCRL(IA);
IF I2=1005∧I3 ∨I2=1004∧¬I3
THEN LINDL(IA,0) ELSE
IF I3∧I2=1004 THEN
LCREDE[IA]←LCREDE[IA]+1;
END;
_ Check for mapping overflow;
IF (CMPIND←CMPIND+1)>63 THEN
BEGIN
QTRC(CL&"Mappings in excess of 63."&
"Isolate best."&CL);
IF BESTMP≠1 THEN
LOOP(IA,0,PARTSI,1)
PARTS[1,IA]←PARTS[BESTMP,IA];
BESTMP←1;
CMPIND ← 2;
END;
_ PARSE cont.;
_ If feature is ordered, try other direction;
REV: IF ¬REVER∧ORD THEN
BEGIN
SUCC←MAP(SCL1,PRL2,IF FTSW THEN 1-DIR
ELSE BITS(IB,22,22) XOR ID);
REVER←1;
GO BA1
END;
_ Display scene?;
IF SUCC+1∧KMP∧MAPTRC LAND '200000 THEN
BEGIN
OUTSTR(CL&"SCENE");
UPPDAL(MAPTRC LAND '400000)
END;
_ Parsing process continues normally with next
key ( = scene-line(s) & prototype &
prototype-line(s) combination).;
PFP←PFEAT[PFP] LAND '7777
END "PFPL";
PRP←PFPRO[PRP] LAND '7777
END "PRPL";
CFP←IF FTSW THEN -FTSW ELSE CFEAT[CFP] LAND '7777;
END "CFPL";
_ Iterate at this point, starting by finding the best
unused key-feature at this stage.;
PFPTR[KADR]←PFPTR[KADR] LOR '400000000000;
GO ITER;
_ Use l.f. keys as well, before deciding on mapping.;
ISO: IF SUCC<1∧FTSW<2 THEN
BEGIN
FTSW←FTSW+1;
LB←1;
UB←PLFTOT;
UBI←MAXNOL;
SCL2←PRL2←MXMXCM←0;
IF FTSW=2 THEN LOOP(IA,1,PLFTOT,1) PFPTR[IA]←
PFPTR[IA] LAND '377777777777;
QTRC((CASE FTSW OF("L","L","P"))&"F-keys"&CL);
GO ITER
END;
_ PARSE cont;
_ Isolation of partial (or complete) object.;
_ First check if the parsing process is at an end.;
IF ¬BESTMP∧¬SUCC THEN
EXH: BEGIN
SQTRC(CL&"SCENE EXHAUST ED - END OF PARSE"&CL);
MAPTRC←0;
IF DTRACE THEN BEGIN CLOSE(DCHAN); DCHAN←-1;END;
RETURN
END;
_ There is a partial or complete. Save mapping.;
I2← IF SUCC=1 THEN CMPIND ELSE BESTMP;
LOOP(I1,0,PARTSI,1) PARTS[CURMAP,I1]←PARTS[I2,I1];
_ Now truck object off to LCREDE=2000+2*CURMAP.;
CMPIND←2000+2*CURMAP;
N1←PARTS[CURMAP,0] LSH -30;
I2←PLINES[N1];
LOOP(I1,1,I2,1)
BEGIN
I3←LPARTL(CURMAP,I1);
MLCR(I3,CMPIND+(LCRL(I3)≠1004));
END;
IF MAPTRC LAND '400 THEN
BEGIN
OUTSTR(CL&"BEST(PARSE) - PROT: "&PNAME[N1]&CL);
LNCRE0←LNCRE2←1006;
LOOP(I1,1,I2,1) MLCR(LPARTL(CURMAP,I1),1006);
UPPDAL(MAPTRC LAND '1000);
LNCRE0←LNCS1;
LNCRE2←LNCS2;
LOOP(I1,1,I2,1) REVIVE(LPARTL(CURMAP,I1))
END;
_ Finally clean up the scene, shipping all replaced lines
(partial lines belonging to the object but superceded as members
of the mapping) into oblivion at LCREDE=3000+CURMAP;
CLUPSC;
_ PARSE end;
IF MAPTRC LAND '4000000 THEN
BEGIN
LNCRE1←1;
LNCRE2←4000;
REGREF(11);
LNCRE1←LNCS1;
LNCRE2←LNCS2;
END;
_ Now the scene may have changed in some relevant way, so before
going through a renewed cross-reference investigation and
feature-extraction, and continuing the parse, we perform an
UNXREF to detach topologically all removed or transferred lines.;
UNXREF;
_ Also make sure we have some active lines left to work on;
I2 ← 0;
LOOP(I1,1,MAXNOL,1) IF LNCRE1≤LCREDE[I1] LAND '400000007777≤LNCRE2
THEN I2←I2+1;
IF I2<3 THEN GO EXH ELSE GO REP;
END "PARSE";
END "MAPS1";